home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / gcl-1.000 / gcl-1 / gcl-1.0 / cmpnew / cmpblock.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1994-05-07  |  6.0 KB  |  171 lines
  1. ;;; CMPBLOCK  Block and Return-from.
  2. ;;;
  3. ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
  4.  
  5. ;; This file is part of GNU Common Lisp, herein referred to as GCL
  6. ;;
  7. ;; GCL is free software; you can redistribute it and/or modify it under
  8. ;;  the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
  9. ;; the Free Software Foundation; either version 2, or (at your option)
  10. ;; any later version.
  11. ;; 
  12. ;; GCL is distributed in the hope that it will be useful, but WITHOUT
  13. ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  14. ;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public 
  15. ;; License for more details.
  16. ;; 
  17. ;; You should have received a copy of the GNU Library General Public License 
  18. ;; along with GCL; see the file COPYING.  If not, write to the Free Software
  19. ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  20.  
  21.  
  22. (in-package 'compiler)
  23.  
  24. (si:putprop 'block 'c1block 'c1special)
  25. (si:putprop 'block 'c2block 'c2)
  26.  
  27. (si:putprop 'return-from 'c1return-from 'c1special)
  28. (si:putprop 'return-from 'c2return-from 'c2)
  29.  
  30. (defstruct blk
  31.            name            ;;; Block name.
  32.            ref            ;;; Referenced or not.  T or NIL.
  33.            ref-clb        ;;; Cross local function reference.
  34.                        ;;; During Pass1, T or NIL.
  35.                        ;;; During Pass2, the vs-address for the
  36.                        ;;; block id, or NIL.
  37.            ref-ccb        ;;; Cross closure reference.
  38.                        ;;; During Pass1, T or NIL.
  39.                        ;;; During Pass2, the ccb-vs for the
  40.                        ;;; block id, or NIL.
  41.            exit            ;;; Where to return.  A label.
  42.            value-to-go        ;;; Where the value of the block to go.
  43.            var            ;;; The block name holder.  Used only in
  44.                        ;;; the error message.
  45.            )
  46.  
  47. (defvar *blocks* nil)
  48.  
  49. ;;; During Pass 1, *blocks* holds a list of blk objects and the symbols 'CB'
  50. ;;; (Closure Boundary) and 'LB' (Level Boundary).  'CB' will be pushed on
  51. ;;; *blocks* when the compiler begins to process a closure.  'LB' will be
  52. ;;; pushed on *blocks* when *level* is incremented.
  53.  
  54. (defun c1block (args)
  55.   (when (endp args) (too-few-args 'block 1 0))
  56.   (cmpck (not (symbolp (car args)))
  57.          "The block name ~s is not a symbol." (car args))
  58.   (let* ((blk (make-blk :name (car args) :ref nil :ref-ccb nil :ref-clb nil))
  59.          (*blocks* (cons blk *blocks*))
  60.          (body (c1progn (cdr args))))
  61.   (if (or (blk-ref-ccb blk) (blk-ref-clb blk))
  62.    (incf *setjmps*))
  63.  
  64.         (if (or (blk-ref-ccb blk) (blk-ref-clb blk) (blk-ref blk))
  65.             (list 'block (reset-info-type (cadr body)) blk body)
  66.             body))
  67.   )
  68.  
  69. (defun c2block (blk body)
  70.   (cond ((blk-ref-ccb blk) (c2block-ccb blk body))
  71.         ((blk-ref-clb blk) (c2block-clb blk body))
  72.         (t (c2block-local blk body))))
  73.  
  74. (defun c2block-local (blk body)
  75.   (setf (blk-exit blk) *exit*)
  76.   (setf (blk-value-to-go blk) *value-to-go*)
  77.   (c2expr body)
  78.   )
  79.  
  80. (defun c2block-clb (blk body &aux (*vs* *vs*))
  81.   (setf (blk-exit blk) *exit*)
  82.   (setf (blk-value-to-go blk) *value-to-go*)
  83.   (setf (blk-ref-clb blk) (vs-push))
  84.   (wt-nl)
  85.   (wt-vs (blk-ref-clb blk))
  86.   (wt "=alloc_frame_id();")
  87.   (wt-nl "frs_push(FRS_CATCH,") (wt-vs (blk-ref-clb blk)) (wt ");")
  88.   (wt-nl "if(nlj_active)")
  89.   (wt-nl "{nlj_active=FALSE;frs_pop();")
  90.   (unwind-exit 'fun-val 'jump)
  91.   (wt "}")
  92.   (wt-nl "else{")
  93.   (let ((*unwind-exit* (cons 'frame *unwind-exit*))) (c2expr body))
  94.   (wt-nl "}")
  95.   )
  96.  
  97. (defun c2block-ccb (blk body &aux (*vs* *vs*) (*clink* *clink*)
  98.                                   (*ccb-vs* *ccb-vs*))
  99.   (setf (blk-exit blk) *exit*)
  100.   (setf (blk-value-to-go blk) *value-to-go*)
  101.   (setf (blk-ref-clb blk) (vs-push))
  102.   (setf (blk-var blk) (add-symbol (blk-name blk)))
  103.   (wt-nl) (wt-vs (blk-ref-clb blk)) (wt "=alloc_frame_id();")
  104.   (wt-nl) (wt-vs (blk-ref-clb blk))
  105.   (wt "=MMcons(") (wt-vs (blk-ref-clb blk)) (wt ",") (wt-clink) (wt ");")
  106.   (clink (blk-ref-clb blk))
  107.   (setf (blk-ref-ccb blk) (ccb-vs-push))
  108.   (wt-nl "frs_push(FRS_CATCH,") (wt-vs* (blk-ref-clb blk)) (wt ");")
  109.   (wt-nl "if(nlj_active)")
  110.   (wt-nl "{nlj_active=FALSE;frs_pop();")
  111.   (unwind-exit 'fun-val 'jump)
  112.   (wt "}")
  113.   (wt-nl "else{")
  114.   (let ((*unwind-exit* (cons 'frame *unwind-exit*))) (c2expr body))
  115.   (wt-nl "}")
  116.   )
  117.  
  118. (defun c1return-from (args)
  119.   (cond ((endp args) (too-few-args 'return-from 1 0))
  120.         ((and (not (endp (cdr args))) (not (endp (cddr args))))
  121.          (too-many-args 'return-from 2 (length args)))
  122.         ((not (symbolp (car args)))
  123.          "The block name ~s is not a symbol." (car args)))
  124.   (do ((blks *blocks* (cdr blks))
  125.        (name (car args))
  126.        (ccb nil) (clb nil))
  127.       ((endp blks)
  128.        (cmperr "The block ~s is undefined." name))
  129.       (declare (object name ccb clb))
  130.       (case (car blks)
  131.             (cb (setq ccb t))
  132.             (lb (setq clb t))
  133.             (t (when (eq (blk-name (car blks)) name)
  134.                      (let ((val (c1expr (cadr args)))
  135.                            (blk (car blks)))
  136.                           (cond
  137.                            (ccb (setf (blk-ref-ccb blk) t))
  138.                            (clb (setf (blk-ref-clb blk) t))
  139.                            (t (setf (blk-ref blk) t)))
  140.                           (return (list 'return-from
  141.                                         (reset-info-type (cadr val))
  142.                                         blk clb ccb val)))))))
  143.   )
  144.  
  145. (defun c2return-from (blk clb ccb val)
  146.   (cond (ccb (c2return-ccb blk val))
  147.         (clb (c2return-clb blk val))
  148.         (t (c2return-local blk val))))
  149.  
  150. (defun c2return-local (blk val)
  151.   (let ((*value-to-go* (blk-value-to-go blk))
  152.         (*exit* (blk-exit blk)))
  153.        (c2expr val))
  154.   )
  155.  
  156. (defun c2return-clb (blk val)
  157.   (let ((*value-to-go* 'top)) (c2expr* val))
  158.   (wt-nl "unwind(frs_sch(")
  159.   (if (blk-ref-ccb blk) (wt-vs* (blk-ref-clb blk)) (wt-vs (blk-ref-clb blk)))
  160.   (wt "),Cnil);")
  161.   )
  162.  
  163. (defun c2return-ccb (blk val)
  164.   (wt-nl "{frame_ptr fr;")
  165.   (wt-nl "fr=frs_sch(") (wt-ccb-vs (blk-ref-ccb blk)) (wt ");")
  166.   (wt-nl "if(fr==NULL) FEerror(\"The block ~s is missing.\",1,VV["
  167.          (blk-var blk) "]);")
  168.   (let ((*value-to-go* 'top)) (c2expr* val))
  169.   (wt-nl "unwind(fr,Cnil);}")
  170.   )
  171.